home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / m68_weak.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  2.7 KB  |  79 lines
  1. (herald m86_weak
  2.   (env tsys))
  3.  
  4. ;;; M68CONSTANTS
  5.  
  6. (define-constant header/weak-set   #b1000101)   ; Number headers...
  7. (define-constant header/weak-alist #b1001101)
  8. (define-constant header/weak-table #b1010101)
  9.  
  10. ;;; M68PRIMOPS
  11.  
  12. (define-local-syntax (define-type-predicate name variant . rest)
  13.   `(define-constant ,name
  14.      ,(xcase variant
  15.         ((and)
  16.          `(make-and-type-predicate ',name . ,rest))
  17.         ((header)
  18.          `(make-header-type-predicate ',name . ,rest)))))
  19.  
  20. (define-type-predicate weak-set-header?   header header/weak-set)
  21. (define-type-predicate weak-alist-header? header header/weak-alist)
  22. (define-type-predicate weak-table-header? header header/weak-table)
  23.  
  24. ;;; PREDICATES
  25.  
  26. (define-local-syntax (define-extend-predicate type . header-type)
  27.   (let ((header-type (if (atom? header-type) type (car header-type))))
  28.     `(define-constant (,(concatenate-symbol type '?) x)
  29.        (and (extend? x)
  30.             (,(concatenate-symbol header-type '-header?) (extend-header x))))))
  31.  
  32. (define-extend-predicate weak-set)
  33. (define-extend-predicate weak-alist)
  34. (define-extend-predicate weak-table)
  35.  
  36. ;;; LOCATIONS
  37.  
  38. (define-local-syntax (define-accessor name offset arg-type qtype . contents)
  39.   (let* ((s-type (if (eq? arg-type 'list) 'pair arg-type))
  40.          (c-type (if (null? contents) 'top (car contents)))
  41.          (type (->type `(object (proc #f (proc #f ,c-type) ,arg-type)
  42.                           (setter #f (proc #f (proc #f ,s-type ,c-type))))))
  43.          (contents-type (->type `(proc #f (proc #f ,c-type) top ,arg-type)))
  44.          (set-type (->type `(proc #f (proc #f) top ,c-type ,s-type))))
  45.     `(define-constant ,name
  46.                       (make-location ',name
  47.                                      ,(if (eq? arg-type 'list)
  48.                                           (fx- (fx* offset 4) 3)
  49.                                           (fx+ (fx* offset 4) 2))
  50.                                      'rep/pointer
  51.                                      ',qtype
  52.                                      1
  53.                                      ',type
  54.                                      ',contents-type
  55.                                      ',set-type))))
  56.  
  57. (define-accessor weak-set-elements   0 top weak-set?)    
  58. (define-accessor weak-alist-elements 0 top weak-alist?)    
  59. (define-accessor weak-table-table    0 top weak-table?)
  60. (define-accessor weak-table-vector   1 top weak-table?)
  61.  
  62. ;;; anywhere
  63.  
  64. (define-integrable (weak-semaphore-set? weak)
  65.   (not (alt-bit-set? weak)))
  66.  
  67. (define-integrable (set-weak-semaphore weak)
  68.   (cond ((weak-semaphore-set? weak)
  69.          (error "simultaneous access on weak ~S" weak))
  70.         (else
  71.          (clear-alt-bit! weak))))
  72.  
  73. (define-integrable (clear-weak-semaphore weak)
  74.   (set-alt-bit! weak))
  75.  
  76.  
  77.  
  78.  
  79.